MacFormat 1995 January/macformat-020.iso/Shareware City/Applications/Alpha.5.96 folder/Tcl/SystemCode/misc.tcl

Text File | 1994-08-30 | 14.1 KB | 592 lines | [TEXT/ALFA]

#===========================================================================
# Information about a selection or window.
#===========================================================================
proc wordCount {} {
    if {[set chars [expr {[selEnd] - [getPos]}]]} {
        set lines [expr {[lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]}]
        set text [getSelect]
    } else {
        set chars [maxPos]
        set lines [lindex [posToRowCol $chars] 0]
        set text [getText 0 [maxPos]]
    }
    if {[regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " ret]} {
        set words [llength $ret]
    } else {
        set words [llength $text]
    }
    alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
}

# proc matchingLines {} {
#     if [catch {prompt "Regular expression:" ""} reg] return
#     if {![string length $reg]} return
#     set reg ^.*$reg.*$
#     set pos [getPos]
#     set matches 0
#     while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
#         append lines "\r" [format "%4d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch]
#         set pos [lindex $mtch 1]
#         incr matches
#     }
#     new
#     insertText [format "%d matching lines\r-----" $matches] $lines "\r"
# }
proc matchingLines {} {
    if [catch {prompt "Regular expression:" ""} reg] return
    if {![string length $reg]} return
    set reg ^.*$reg.*$
    set pos 0
    set fileName [lindex [winNames -f] 0]
    set matches 0
    while {![catch {search -f 1 -r 1 -m 0 -i 1 $reg $pos} mtch]} {
        append lines "\r" [format "Line %d: " [lindex [posToRowCol [lindex $mtch 0]] 0]] [eval getText $mtch] "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t∞$fileName"
        set pos [lindex $mtch 1]
        incr matches
    }
    new -n {* Matching Lines *}
    insertText [format "%d matching lines (<cr> to go to match)\r-----" $matches] $lines "\r"
    select [nextLineStart [nextLineStart 0]] [nextLineStart [nextLineStart [nextLineStart 0]]]

    global winModes
    set name [lindex [winNames] 0]
    changeMode [set winModes($name) Brws]
    setWinInfo dirty 0
    setWinInfo read-only 1
}

#=============================================================================
# Random functions.
#=============================================================================

#***********************************************************************
#                                                                      *
#   Comment box and uncomment box courtesy of Igor Mikolic-Torreira.   *
#                                                                      *
#**********************************************************************/

proc commentBox {} {

# Preliminaries

    if {[getPos] == [selEnd]} {
        alertnote "Must select region to be commented."
        return
    }
    global lastMode
    watchCursor

# Set what the comment block will look like

    case $lastMode in {
        "Text" {
            set begComment "!"
            set begComLen 1
            set endComment "!"
            set endComLen 1
            set fillChar "!"
            set spaceOffset 3
        }
        "Fort" {
            set begComment "C"
            set begComLen 1
            set endComment "C"
            set endComLen 1
            set fillChar "C"
            set spaceOffset 3
        }
        "Tcl" {
            set begComment "#"
            set begComLen 1
            set endComment "#"
            set endComLen 1
            set fillChar "#"
            set spaceOffset 3
        }
        "C" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        "C++" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        default {
            alertnote "I don't know what comments should look like in this mode.  Sorry."
            return
        }
    }
    set aSpace " "

# First make sure we grab a full block of lines and adjust highlight

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [expr $end-1]]
    select $start $end

# Now get rid of any tabs

    if { $end < [maxPos] } then {
        createTMark stopComment [expr $end+1]
        tabsToSpaces
        gotoTMark stopComment
        set end [expr [getPos]-1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r"]
    set emptyLine [lsearch $lineList {}]
    if { $emptyLine != -1 } then {
        set numLines [llength $lineList]
        set lineList [lrange $lineList 0 [expr $numLines-2]]
    }
    set numLines [llength $lineList]

# Find the longest line length and determine the new line length

    set maxLength 0
    foreach thisLine $lineList {
        set thisLength [string length $thisLine]
        if { $thisLength > $maxLength } then {
            set maxLength $thisLength
        }
    }
    set newLength [expr {$maxLength + 2 + 2*$spaceOffset}]

# Now create the top & bottom bars and a blank line

    set topBar $begComment
    for { set i 0 } { $i < [expr {$newLength - $begComLen}] } { incr i } {
        set topBar $topBar$fillChar
    }
    set botBar ""
    for { set i 0 } { $i < [expr {$newLength - $endComLen}] } { incr i } {
        set botBar $botBar$fillChar
    }
    set botBar $botBar$endComment
    set blankLine $fillChar
    for { set i 0 } { $i < [expr {$newLength - 2}] } { incr i } {
        set blankLine $blankLine$aSpace
    }
    set blankLine $blankLine$fillChar

# For each line add stuff on left and spaces and stuff on right for box sides
# and concatenate everything into 'text'.  Start with topBar; end with botBar

    set text $topBar\r$blankLine\r

    set frontStuff $fillChar
    set backStuff $fillChar
    for { set i 0 } { $i < $spaceOffset } { incr i } {
        set frontStuff $frontStuff$aSpace
        set backStuff $aSpace$backStuff
    }
    set backStuffLen [string length $backStuff]

    for { set i 0 } { $i < $numLines } { incr i } {
        set thisLine [lindex $lineList $i ]
        set thisLine $frontStuff$thisLine
        set thisLength [string length $thisLine]
        set howMuchPad [expr {$newLength - $thisLength - $backStuffLen}]
        for { set j 0 } { $j < $howMuchPad } { incr j } {
            set thisLine $thisLine$aSpace
        }
        set thisLine $thisLine$backStuff
        set text $text$thisLine\r
    }

    set text $text$blankLine\r$botBar\r

# Now replace the old stuff, turn spaces to tabs, and highlight

    replaceText    $start $end    $text
    set end [expr {$start+[string length $text]}]
    createTMark stopComment [expr $end+1]
    select $start $end
    spacesToTabs
    gotoTMark stopComment
    set end [expr [getPos]-1]
    removeTMark stopComment
    select $start $end
}



proc uncommentBox {} {

# Preliminaries

    if {[getPos] == [selEnd]} {
        alertnote "Must select region to be uncommented."
        return
    }
    global lastMode
    watchCursor

# Set what the comment block will look like

    case $lastMode in {
        "Text" {
            set begComment "!"
            set begComLen 1
            set endComment "!"
            set endComLen 1
            set fillChar "!"
            set spaceOffset 3
        }
        "Fort" {
            set begComment "C"
            set begComLen 1
            set endComment "C"
            set endComLen 1
            set fillChar "C"
            set spaceOffset 3
        }
        "Tcl" {
            set begComment "#"
            set begComLen 1
            set endComment "#"
            set endComLen 1
            set fillChar "#"
            set spaceOffset 3
        }
        "C" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        "C++" {
            set begComment "/*"
            set begComLen 2
            set endComment "*/"
            set endComLen 2
            set fillChar "*"
            set spaceOffset 3
        }
        default {
            alertnote "I don't know what comments should look like in this mode.  Sorry."
            return
        }
    }
    set aSpace " "
    set aTab \t

# First make sure we grab a full block of lines

    set start [getPos]
    set start [lineStart $start]
    set end [selEnd]
    set end [nextLineStart [expr $end-1]]
    set text [getText $start $end]

# Make sure we're at the start and end of the box

    set startOK [string first $begComment $text]
    set endOK [string last $endComment $text]
    set textLength [string length $text]
    if { $startOK != 0 || ($endOK != [expr {$textLength-$endComLen-1}] || $endOK == -1) } then {
        alertnote "You must highlight the entire comment box, including the borders."
        return
    }

# Now get rid of any tabs

    if { $end < [maxPos] } then {
        createTMark stopComment [expr $end+1]
        tabsToSpaces
        gotoTMark stopComment
        set end [expr [getPos]-1]
        removeTMark stopComment
    } else {
        tabsToSpaces
        set end [maxPos]
    }
    select $start $end
    set text [getText $start $end]

# Next turn it into a list of lines--possibly drop an empty 'last line'

    set lineList [split $text "\r"]
    set emptyLine [lsearch $lineList {}]
    if { $emptyLine != -1 } then {
        set numLines [llength $lineList]
        set lineList [lrange $lineList 0 [expr $numLines-2]]
    }
    set numLines [llength $lineList]

# Delete the first and last lines, recompute number of lines

    set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
    set lineList [lreplace $lineList 0 0 ]
    set numLines [llength $lineList]

# Eliminate 2nd and 2nd-to-last lines if they are empty

    set eliminate $fillChar$aSpace$aTab
    set thisLine [lindex $lineList [expr $numLines-1]]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } then {
        set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
    }
    set thisLine [lindex $lineList 0]
    set thisLine [string trim $thisLine $eliminate]
    if { [string length $thisLine] == 0 } then {
        set lineList [lreplace $lineList 0 0 ]
    }
    set numLines [llength $lineList]

# For each line trim stuff on left and spaces and stuff on right and splice

    set dropFromLeft [expr $spaceOffset+1]
    set text ""
    for { set i 0 } { $i < $numLines } { incr i } {
        set thisLine [lindex $lineList $i]
        set thisLine [string trimright $thisLine $eliminate]
        set thisLine [string range $thisLine $dropFromLeft end]
        set text $text$thisLine\r
    }

# Now replace the old stuff, convert spaces back to tabs

    replaceText    $start $end    $text
    set end [expr {$start+[string    length $text]}]
    createTMark stopComment [expr $end+1]
    select $start $end
    spacesToTabs
    gotoTMark stopComment
    set end [expr [getPos]-1]
    removeTMark stopComment
    select $start $end
}


#================================================================================

proc transposeWords {} {
    global intelCutPaste

    set intel $intelCutPaste
    set intelCutPaste 0
    forwardWord
    setMark
    backwardWord
    cut
    deleteChar
    forwardWord
    insertText "\ "
    paste
    set intelCutPaste $intel
}

proc transposeChars {} {
     global intelCutPaste

    set intel $intelCutPaste
    set intelCutPaste 0
    setMark
    forwardChar
    cut
    backwardChar
    paste
    forwardChar
    set intelCutPaste $intel
}

proc nextFunc {} {
    searchFunc 1
}

proc prevFunc {} {
    searchFunc 0
}

proc searchFunc {dir} {
    global funcExpr
    set pos [getPos]
    select $pos
    if ($dir==1) {
        incr pos
    } else {
        set pos [expr $pos-1]
    }
    if {![catch {search -f $dir -i 1 -r 1 $funcExpr $pos} res]} {
        eval select $res
    }
}

#===========================================================================
# Comment routines.
#===========================================================================
proc commentPara {} {
}



#===========================================================================
# Sorting the selection.
# AUTHOR: David C. Black     [e-mail]
#===========================================================================
proc sortLines {} {
    set ends [getEndpts]
    set start [lindex $ends 0]
    set end  [lindex $ends 1]
    if {$start == $end} {
        alertnote "You must highlight the section you wish to sort."
        return
    }
    if {[lookAt [expr $end-1]] != "\r"} {
        alertnote "The selection must consist only of complete lines."
        return
    }
    set text [getText $start [expr {$end-1}]]
    set text [join [lsort [split $text "\r"]] "\r"]
    replaceText $start [expr {$end-1}] $text
    select $start $end
}



#===========================================================================
# Dump all current settings into a file.
#===========================================================================
proc insertGlobalSettings {} {
    uplevel #0 {
        foreach var [info globals] {
            if {![catch {set $var}]} {
                insertText "set " $var " \{" [set $var] "\}\r"
            }
        }
    }
}


#================================================================================
# Substitute global variables in possibly nested list.
#================================================================================
proc subVars {words} {
    global silly
    global a
    set silly $words
    set out {}
    foreach a $words {
        if {[llength $a] == 1} {
            lappend out [uplevel #0 {eval set x $a}]
        } else {
            lappend out [subVars $a]
        }
    }
    return $out
}

#================================================================================
# Block shift left and right.
#================================================================================
set shiftChar    "\t"

proc shiftLeft {} {
    global shiftChar

     set start [lineStart [getPos]]
     set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    foreach line $text {
        if {[string index $line 0] == $shiftChar} {
            lappend textout [string range $line 1 end]
        } else {
            lappend textout $line
        }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}


proc shiftRight {} {
    global    shiftChar

    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    foreach line $text {
        lappend textout $shiftChar$line
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}



# rglob [option list] dir pat
# 'dir' should be a properly formed directory, ending w/ a ':'. 'pat' should be
# a simple pattern w/ no directory specifications (i.e. "*.c").
proc rglob {optlist dir pat} {

    set cmd [concat glob $optlist]
    lappend cmd $dir$pat
    if {[catch {eval $cmd} files]} {
        set files ""
    }

    if {![catch {glob $dir*} all]} {
        foreach f $all {
            if {[file isdir $f]} {
                set files [concat $files [rglob $optlist $f: $pat]]
            }
        }
    }
    return $files
}


proc switchApp {} {
    set procs ""
    foreach p [processes] {
        lappend procs [lindex $p 0]
    }
    set to [listpick -p "Switch to app:" $procs]
    if {[string length $to]} {
        switchTo $to
    }
}


proc selectAll {} {
    select 0 [maxPos]
}